home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / sset.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  8.9 KB  |  301 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: sset.lisp,v 1.4 91/02/20 14:59:48 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    A sparse set abstraction, implemented as a sorted linked list.  We don't
  15. ;;; use bit-vectors to represent sets in flow analysis, since the universe may
  16. ;;; be quite large but the average number of elements is small.  We keep the
  17. ;;; list sorted so that we can do union and intersection in linear time.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. (in-package 'c)
  22.  
  23. ;;;
  24. ;;; Each structure that may be placed in a SSet must include the SSet-Element
  25. ;;; structure.  We allow an initial value of NIL to mean that no ordering has
  26. ;;; been assigned yet (although an ordering must be assigned before doing set
  27. ;;; operations.)
  28. ;;;
  29. (defstruct sset-element
  30.   (number nil :type (or index null)))
  31.  
  32.  
  33. (defstruct (sset (:constructor make-sset ())
  34.          (:copier nil)
  35.          (:print-function %print-sset))
  36.   (elements (list nil) :type list))
  37.  
  38.  
  39. (defprinter sset
  40.   (elements :prin1 (cdr elements)))
  41.  
  42.  
  43. ;;; Do-Elements  --  Interface
  44. ;;;
  45. ;;;    Iterate over the elements in Set, binding Var to each element in turn.
  46. ;;;
  47. (defmacro do-elements ((var set &optional result) &body body)
  48.   `(dolist (,var (cdr (sset-elements ,set)) ,result) ,@body))
  49.  
  50.  
  51. ;;; SSet-Adjoin  --  Interface
  52. ;;;
  53. ;;;    Destructively add Element to Set.  If Element was not in the set, then
  54. ;;; we return true, otherwise we return false.
  55. ;;;
  56. (proclaim '(function sset-adjoin (sset-element sset) boolean))
  57. (defun sset-adjoin (element set)
  58.   (let ((number (sset-element-number element))
  59.     (elements (sset-elements set)))
  60.     (do ((prev elements current)
  61.      (current (cdr elements) (cdr current)))
  62.     ((null current)
  63.      (setf (cdr prev) (list element))
  64.      t)
  65.       (let ((el (car current)))
  66.     (when (>= (sset-element-number el) number)
  67.       (when (eq el element)
  68.         (return nil))
  69.       (setf (cdr prev) (cons element current))
  70.       (return t))))))
  71.  
  72.  
  73. ;;; SSet-Delete  --  Interface
  74. ;;;
  75. ;;;    Destructively remove Element from Set.  If element was in the set,
  76. ;;; then return true, otherwise return false.
  77. ;;;
  78. (proclaim '(function sset-delete (sset-element sset) boolean))
  79. (defun sset-delete (element set)
  80.   (let ((elements (sset-elements set)))
  81.     (do ((prev elements current)
  82.      (current (cdr elements) (cdr current)))
  83.     ((null current) nil)
  84.       (when (eq (car current) element)
  85.     (setf (cdr prev) (cdr current))
  86.     (return t)))))
  87.  
  88.  
  89. ;;; SSet-Member  --  Interface
  90. ;;;
  91. ;;;    Return true if Element is in Set, false otherwise.
  92. ;;;
  93. (proclaim '(function sset-member (sset-element sset) boolean))
  94. (defun sset-member (element set)
  95.   (declare (inline member))
  96.   (not (null (member element (cdr (sset-elements set)) :test #'eq))))
  97.  
  98.  
  99. ;;; SSet-Empty  --  Interface
  100. ;;;
  101. ;;;    Return true if Set contains no elements, false otherwise.
  102. ;;;
  103. (proclaim '(function sset-empty (sset) boolean))
  104. (defun sset-empty (set)
  105.   (null (cdr (sset-elements set))))
  106.  
  107.  
  108. ;;; SSet-Singleton  --  Interface
  109. ;;;
  110. ;;;    If Set contains exactly one element, then return it, otherwise return
  111. ;;; NIL.
  112. ;;;
  113. (proclaim '(function sset-singleton (sset) (or sset-element null)))
  114. (defun sset-singleton (set)
  115.   (let ((elements (cdr (sset-elements set))))
  116.     (if (and elements (not (cdr elements)))
  117.     (car elements)
  118.     nil)))
  119.  
  120.  
  121. ;;; SSet-Subsetp  --  Interface
  122. ;;;
  123. ;;;    If Set1 is a (not necessarily proper) subset of Set2, then return true,
  124. ;;; otherwise return false.
  125. ;;;
  126. (proclaim '(function sset-subsetp (sset sset) boolean))
  127. (defun sset-subsetp (set1 set2)
  128.   (let ((el2 (cdr (sset-elements set2))))
  129.     (do ((el1 (cdr (sset-elements set1)) (cdr el1)))
  130.     ((null el1) t)
  131.       (let ((num1 (sset-element-number (car el1))))
  132.     (loop
  133.       (when (null el2) (return-from sset-subsetp nil))
  134.       (let ((num2 (sset-element-number (pop el2))))
  135.         (when (>= num2 num1)
  136.           (when (> num2 num1) (return-from sset-subsetp nil))
  137.           (return))))))))
  138.  
  139.  
  140. ;;; SSet-Equal  --  Interface
  141. ;;;
  142. ;;;    Return true if Set1 and Set2 contain the same elements, false otherwise.
  143. ;;;
  144. (proclaim '(function sset-equal (sset sset) boolean))
  145. (defun sset-equal (set1 set2)
  146.   (do ((el1 (cdr (sset-elements set1)) (cdr el1))
  147.        (el2 (cdr (sset-elements set2)) (cdr el2)))
  148.       (())
  149.     (when (null el1) (return (null el2)))
  150.     (when (null el2) (return nil))
  151.     (unless (eq (car el1) (car el2)) (return nil))))
  152.  
  153.  
  154. ;;; Copy-SSet  --  Interface
  155. ;;;
  156. ;;;    Return a new copy of Set.
  157. ;;;
  158. (proclaim '(function copy-sset (sset) sset))
  159. (defun copy-sset (set)
  160.   (let ((res (make-sset)))
  161.     (setf (sset-elements res) (copy-list (sset-elements set)))
  162.     res))
  163.  
  164.  
  165. ;;; SSet-Union, SSet-Intersection, SSet-Difference  --  Interface
  166. ;;;
  167. ;;; Perform the appropriate set operation on Set1 and Set2 by destructively
  168. ;;; modifying Set1.  We return true if Set1 was modified, false otherwise.
  169. ;;;
  170. (proclaim '(ftype (function (sset sset) boolean) sset-union sset-intersection
  171.           sset-difference))
  172. (defun sset-union (set1 set2)
  173.   (let* ((prev-el1 (sset-elements set1))
  174.      (el1 (cdr prev-el1))
  175.      (changed nil))
  176.     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
  177.     ((null el2) changed)
  178.       (let* ((e (car el2))
  179.          (num2 (sset-element-number e)))
  180.     (loop
  181.       (when (null el1)
  182.         (setf (cdr prev-el1) (copy-list el2))
  183.         (return-from sset-union t))
  184.       (let ((num1 (sset-element-number (car el1))))
  185.         (when (>= num1 num2)
  186.           (if (> num1 num2)
  187.           (let ((new (cons e el1)))
  188.             (setf (cdr prev-el1) new)
  189.             (setq prev-el1 new  changed t))
  190.           (shiftf prev-el1 el1 (cdr el1)))
  191.           (return))
  192.         (shiftf prev-el1 el1 (cdr el1))))))))
  193. ;;;
  194. (defun sset-intersection (set1 set2)
  195.   (let* ((prev-el1 (sset-elements set1))
  196.      (el1 (cdr prev-el1))
  197.      (changed nil))
  198.     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
  199.     ((null el2)
  200.      (cond (el1
  201.         (setf (cdr prev-el1) nil)
  202.         t)
  203.            (t changed)))
  204.       (let ((num2 (sset-element-number (car el2))))
  205.     (loop
  206.       (when (null el1)
  207.         (return-from sset-intersection changed))
  208.       (let ((num1 (sset-element-number (car el1))))
  209.         (when (>= num1 num2)
  210.           (when (= num1 num2)
  211.         (shiftf prev-el1 el1 (cdr el1)))
  212.           (return))
  213.         (pop el1)
  214.         (setf (cdr prev-el1) el1)
  215.         (setq changed t)))))))
  216. ;;;
  217. (defun sset-difference (set1 set2)
  218.   (let* ((prev-el1 (sset-elements set1))
  219.      (el1 (cdr prev-el1))
  220.      (changed nil))
  221.     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
  222.     ((null el2) changed)
  223.       (let ((num2 (sset-element-number (car el2))))
  224.     (loop
  225.       (when (null el1)
  226.         (return-from sset-difference changed))
  227.       (let ((num1 (sset-element-number (car el1))))
  228.         (when (>= num1 num2)
  229.           (when (= num1 num2)
  230.         (pop el1)
  231.         (setf (cdr prev-el1) el1)
  232.         (setq changed t))
  233.           (return))
  234.         (shiftf prev-el1 el1 (cdr el1))))))))
  235.  
  236.  
  237. ;;; SSet-Union-Of-Difference  --  Interface
  238. ;;;
  239. ;;;    Destructively modify Set1 to include its union with the difference of
  240. ;;; Set2 and Set3.  We return true if Set1 was modified, false otherwise.
  241. ;;;
  242. (proclaim '(function sset-union-of-difference (sset sset sset) boolean))
  243. (defun sset-union-of-difference (set1 set2 set3)
  244.   (let* ((prev-el1 (sset-elements set1))
  245.      (el1 (cdr prev-el1))
  246.      (el3 (cdr (sset-elements set3)))
  247.      (changed nil))
  248.     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
  249.     ((null el2) changed)
  250.       (let* ((e (car el2))
  251.          (num2 (sset-element-number e)))
  252.     (loop
  253.       (when (null el3)
  254.         (loop
  255.           (when (null el1)
  256.         (setf (cdr prev-el1) (copy-list el2))
  257.         (return-from sset-union-of-difference t))
  258.           (let ((num1 (sset-element-number (car el1))))
  259.         (when (>= num1 num2)
  260.           (if (> num1 num2)
  261.               (let ((new (cons e el1)))
  262.             (setf (cdr prev-el1) new)
  263.             (setq prev-el1 new  changed t))
  264.               (shiftf prev-el1 el1 (cdr el1)))
  265.           (return))
  266.         (shiftf prev-el1 el1 (cdr el1))))
  267.         (return))
  268.       (let ((num3 (sset-element-number (car el3))))
  269.         (when (<= num2 num3)
  270.           (unless (= num2 num3)
  271.         (loop
  272.           (when (null el1)
  273.             (do ((el2 el2 (cdr el2)))
  274.             ((null el2)
  275.              (return-from sset-union-of-difference changed))
  276.               (let* ((e (car el2))
  277.                  (num2 (sset-element-number e)))
  278.             (loop
  279.               (when (null el3)
  280.                 (setf (cdr prev-el1) (copy-list el2))
  281.                 (return-from sset-union-of-difference t))
  282.               (setq num3 (sset-element-number (car el3)))
  283.               (when (<= num2 num3)
  284.                 (unless (= num2 num3)
  285.                   (let ((new (cons e el1)))
  286.                 (setf (cdr prev-el1) new)
  287.                 (setq prev-el1 new  changed t)))
  288.                 (return))
  289.               (pop el3)))))
  290.           (let ((num1 (sset-element-number (car el1))))
  291.             (when (>= num1 num2)
  292.               (if (> num1 num2)
  293.               (let ((new (cons e el1)))
  294.                 (setf (cdr prev-el1) new)
  295.                 (setq prev-el1 new  changed t))
  296.               (shiftf prev-el1 el1 (cdr el1)))
  297.               (return))
  298.             (shiftf prev-el1 el1 (cdr el1)))))
  299.           (return)))
  300.       (pop el3))))))
  301.